perm filename SCANZ.F4[LX,LCS]3 blob
sn#166779 filedate 1975-07-03 generic text, type T, neo UTF8
00100 C ***** SCANNER *************************
00200 C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR 7/74
00300 SUBROUTINE SCANR
00400 DIMENSION IP(30)
00500 COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
00600 1 ,IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
00700 1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
00800 EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
00900 1 ,(IEN,ISCA(4)),(IP,PL)
01000 C 2/74 IP IS NOW EQUIV TO PL! USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
01100 C WILL THIS DO ANYTHING TO MUSIC5 VERSION??
01200 NNUM=-1
01300 ISKP=0
01400 JJ=0
01500 XMINUS=1.
01600 999 IDECI=-1
01700 M=0
01800 2799 N=INP(ML)
01900 IF(N.NE.IQT)GO TO 899
02000 JA=-1
02100 ML=ML+1
02200 ISUB=8
02300 JJ=JJ+1
02400 VX(JJ)=ML
02500 C POINTS TO FIRST LIT. CHAR.
02600 DO 1177 K=ML,144
02700 IF(INP(K).NE.IQT)GO TO 1177
02800 ML=K+1
02900 2177 N=INP(ML)
03000 GO TO 899
03100 1177 CONTINUE
03200 C SKIPS 'LIT' ITEMS IN RAN. SELECTION
03300 899 ML=ML+1
03400 IF(N.EQ.ISEMI)GO TO 751
03500 IF(N.NE.IBLA)GO TO 510
03600 4702 IF(ISKP)202,2799,2799
03700
03800 510 IF(JA)GO TO 70
03900 C********** MAY 22,71
04000 DO 77 K=1,12
04100 IF(N.NE.ISCA(K))GO TO 77
04200 IF(K.EQ.2)GO TO 1511
04250 IF(K.NE.4)GO TO 511
04300 1511 NSWCH=K-4
04400 GO TO 2177
04500 C TO SWITCH ALWAYS USE OCT.# /PBF4/ /OE5/ P=PROXIMITY, O=ORDINARY
04600 C ************ MAY 22,71
04700 511 NNUM=K
04800 JJ=JJ+1
04900 NFLG=-1
05000 N=INP(ML)
05100 IF(N.NE.IF)GO TO 410
05200 NNUM=NNUM-1
05300 GO TO 610
05400 410 IF(N.NE.ISS)GO TO 3410
05500 NNUM=NNUM+1
05600 610 ML=ML+1
05700 N=INP(ML)
05800 3410 IF(N.EQ.IEN)GO TO 3411
05850 IF(N.NE.'I')GO TO 371
05900 C 'END' OR 'FINE' WILL END INST.
06000 C******** MAY 20,71
06100 3411 VX(JJ)=10000.
06200 IF(DUR(LK))DUR(LK)=1000.
06300 IAMP=-1
06400 RETURN
06500 371 IF(N.EQ.ISEMI)GO TO 5410
06550 IF(N.EQ.IBLA)GO TO 5410
06600 DO 177 KN=2,8
06700 IF(N.NE.IDAT(KN))GO TO 177
06800 JSCA=KN-2
06900 ML=ML+1
07000 GO TO 2410
07100 177 CONTINUE
07200 GO TO 6410
07300 5410 KN=-1
07400 6410 IF(NSWCH.EQ.0)GO TO 2410
07500 IF(KN)GO TO 7410
07600 CC IF(N.EQ.'+')NOLD=NOLD+6
07700 CC IF(N.EQ.'-')NOLD=NOLD-6
07800 C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
07900 7410 IF(NOLD-NNUM.LE.5)GO TO 7411
07950 IF(JSCA.LT.7)JSCA=JSCA+1
08000 7411 IF(NOLD-NNUM.GE.-5)GO TO 2410
08050 IF(JSCA.GT.0)JSCA=JSCA-1
08100 C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
08200 2410 VX(JJ)=JSCA*12+NNUM
08300 NOLD=NNUM
08400 C ********** MAY 22,71
08500 4410 NNUM=-2
08600 IF(INP(ML).EQ.ISEMI)RETURN
08700 C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
08800 IF(N.EQ.IXX)GO TO 210
08850 IF(N.EQ.'*')GO TO 210
08900 GO TO 310
09000 C *********MAY 22,71
09100 77 CONTINUE
09200 70 IF(N.NE.'-')GO TO 71
09300 XMINUS=-1.
09400 GO TO 2799
09500 210 JJ=JJ+1
09600 IF(JJ.EQ.1)GO TO 3310
09700 C****** MAY 19,71
09800 XMINUS=1.
09900 VX(JJ)=0
10000 C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
10100 GO TO 310
10200 71 IF(N.EQ.IXX)GO TO 210
10210 IF(N.EQ.'*')GO TO 210
10300 IF(N.EQ.'R')GO TO 73
10400
10500 1410 DO 78 K=1,11
10600 IF(N.NE.IDAT(K))GO TO 78
10700 ISKP=-1
10800 IF(N.NE.IDOT)GO TO 79
10900 IDECI=M
11000 GO TO 75
11100 79 M=M+1
11200 IP(M)=K-1
11300 GO TO 75
11400 78 CONTINUE
11500 IF(N.EQ.IE)GO TO 7811
11550 IF(N.NE.IF)GO TO 781
11600 C 'END' OR 'FINE' WILL END INST.
11700 7811 JJ=1
11800 GO TO 3411
11900 781 IF(N.EQ.'/')N=ISEMI
12000 C FOR MOTIVIC TRANFORMATIONS
12100
12110 75 KN=INP(ML)
12200 IF(KN.EQ.IXX)GO TO 202
12210 IF(KN.EQ.'*')GO TO 202
12300 C FOR 2X3, 2*3, ETC. CHECK THIS OUT. 6/74
12400 CC75 IF(INP(ML).NE.IXX)GO TO 752
12500 CC ML=ML-1
12600 CC GO TO 202
12700 C FOR 'X' AND '*' WITHOUT SPACES.
12800 IF(N.EQ.ISEMI)GO TO 751
12850 IF(KN.NE.1)GO TO 2799
12875 C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
12900 751 IF(ISKP.EQ.0)RETURN
13000 202 IF(IDECI.NE.-1)GO TO 302
13100 IDECI=0
13200 GO TO 402
13300 302 IDECI=M-IDECI
13400 402 KN=0
13500 IEXP=M-1
13600 IF(M.LT.1)M=1
13700 DO 171 K=1,M
13800 KV=10**IEXP
13900 IF(IEXP.EQ.0)KV=1
14000 KN=KN+IP(K)*KV
14100 171 IEXP=IEXP-1
14200 A=10**IDECI
14300 IF(IDECI.EQ.0)A=1.
14400 JJ=JJ+1
14500 VX(JJ)=KN/A*XMINUS
14600 IF(ISUB.EQ.1)RETURN
14700 IF(CODE.NE.-22.)XMINUS=1.
14800 C ONLY ONE - NEEDED FOR RHY.COMPOSITE
14900 1310 IF(INP(ML).NE.1)GO TO 310
15000 VX(JJ+1)=VX(JJ)*2.
15100 JJ=JJ+1
15200 ML=ML+1
15300 GO TO 1310
15400 206 ML=ML+2
15500 3310 VX(1)=-99.
15600 C******** MAY 19,71
15700 310 ISKP=0
15800 IF(N.NE.ISEMI)GO TO 999
15900
16000 RETURN
16100 73 JJ=JJ+1
16200 IF(INP(ML).EQ.IE)GO TO 206
16300 C NEXT IS FOR A REST ('R')
16400 VX(JJ)=85.
16500 GO TO 4410
16600 END
16700
16800 SUBROUTINE BGSORT(BW)
16900 C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
17000 C ALLOWS 100 BG TIMES.
17100 COMMON /Q/ BNW(100),NWZ
17200 DO 5308 K=1,NWZ
17300 X=BNW(K)-.0001
17400 Y=X+.0002
17500 C ROUND-OFF NONSENSE
17600 5308 IF(BW.LE.X)GO TO 5309
17650 IF(BW.LT.Y)RETURN
17700 5309 NWZ=NWZ+1
17800 BNW(NWZ)=BW
17900 RETURN
18000 END
18100
18200 SUBROUTINE FMT(JFM,INP,MLX)
18300 DIMENSION JFM(3),INP(1)
18400 DO 1 MLX=2,72
18500 J=INP(MLX)
18600 1 IF(J.EQ.' ')GO TO 2
18650 IF(J.EQ.',')GO TO 2
18675 IF(J.EQ.';')GO TO 2
18700 C SPACE=COMMA=SPACE, ALSO STOPS ON ";"
18800 2 MLX=MLX+1
18900 IF(MLX.GT.7)MLX=7
19000 JFM(2)='0'+(MLX-2)*536870912
19100 C FINDS NUMBER FOR 'A' FORMAT
19200 RETURN
19300 END
19400
19500 SUBROUTINE RANR(VX,K)
19600 C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
19700 DIMENSION VX(1)
19800 X=VX(K)
19900 Y=VX(K+1)
20000 IF(X.GT.Y)VX(K)=X+.999
20100 IF(Y.GE.X)VX(K+1)=Y+.999
20200 RETURN
20300 END
20400
20500 SUBROUTINE SQYY(YY,X,Y,Z)
20600 YY=2.*Z/(X+Y)
20700 IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
20800 RETURN
20900 END
21000
21100 SUBROUTINE COLTTY(JNP,JT)
21200 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
21300 DIMENSION JNP(1)
21400 DATA J(2)/'72A1)'/
21500 DO 1 K=72,1,-1
21600 1 IF(JNP(K).NE.' ')GO TO 2
21700 K=1
21800 2 IF(JT.EQ.21)GO TO 3
21900 J(1)=' (1X'
22000 IF(LN.EQ.0)GO TO 5
22100 J(1)='(I5,X'
22200 WRITE(JT,J)LN,(JNP(L),L=1,K)
22300 RETURN
22400 3 J(1)=' ('
22500 5 WRITE(JT,J)(JNP(L),L=1,K)
22600 END
22700
22800 FUNCTION READER(JNP)
22900 DIMENSION JNP(72)
23000 COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
23100 1 /FRMT/J(2)
23200 DATA TPALN/20H(' TYPE A LINE'/) /
23300 J(1)=' ('
23400 READER=0
23500 IF(ITYP)GO TO 1
23600 6 TYPE TPALN
23700 ACCEPT J,JNP
23800 IF(JED)CALL COLTTY(JNP,21)
23900 IF(JNP(1).EQ.' ')GO TO 6
24000 RETURN
24100 1 IF(LN.NE.0)GO TO 5
24200 READ(1,J,END=3)JNP
24300 GO TO 7
24400 5 J(1)=' (I,'
24500 READ(1,J,END=3)LN,JNP
24600 7 IF(SOS)CALL COLTTY(JNP,JOUT)
24700 RETURN
24800 3 READER=-1
24900 END
25000
25100 SUBROUTINE QUAD
25200 C DUMMY -- FOR NOW. 7/74
25300 END
25400
25500 FUNCTION RMOVX(W,Y,Z)
25600 IF(W.EQ.0)W=.01
25700 IF(Y.EQ.0)Y=.01
25800 RMOVX=Y*((W/Y)**Z)
25900 END
26000
26100 SUBROUTINE CLEAN(INP,LEND)
26200 DIMENSION INP(1)
26300 C CLEAR THE END OF ARRAY
26400 M=72
26500 LEND=-1
26600 K=0
26700 1 K=K+1
26800 NN=INP(K)
26900 IF(NN.EQ.';')GO TO 2
26950 IF(NN.EQ.'/')GO TO 2
27000 IF(NN.EQ.'<')GO TO 3
27100 C USE < FOR COMMENT-- AS IN MUS10
27200 IF(NN.EQ.',')INP(K)=' '
27300 C CHANGE ALL COMMAS TO BLANKS
27400 IF(NN.NE.'"')GO TO 4
27500 7 K=K+1
27600 IF(INP(K).EQ.'"')GO TO 4
27700 IF(K.LT.M)GO TO 7
27800 TYPE 5
27900 STOP
28000 5 FORMAT(' OPEN QUOTES')
28100 2 LEND=K
28200 4 IF(K.LT.M)GO TO 1
28300 3 IF(LEND.GT.0)RETURN
28400 IF(M.EQ.144)GO TO 8
28500 CALL READER(INP(73))
28600 C GO READ ANOTHER LINE.
28700 M=144
28800 K=72
28900 GO TO 1
28910 8 TYPE 9
28920 CALL EXIT
28930 9 FORMAT(' NO END MARK'/)
29000 END
29100 SUBROUTINE ACCEL
29200 COMMON/A/ V(2000),ROFF(27),NP(27),PCH(27,32),
29300 1 RDEV(27),IPT(27,31),XT(27),OTH(20,16),SCAL(101)
29400 1 ,P1(27),JFM(4),COPY(30),IFM(80)
29500 1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
29600 COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
29700 1 ,IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
29800 1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
29900 COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
30000 1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
30100 1 ZZ,CHN,YY
30200 1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
30300 1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
30400 1 LP,ILIT,NLIT,KTMP,IC,RAX,RD,IA
30500 C /C/=26
30600 IF(T5.EQ.1)GO TO 4020
30650 XA=RA
30700 7020 RA=V(IA+K)
30800 IF(RA.EQ.10000.)RETURN
30900 4020 RD=1
31000 IF(RA.LT.0)RD=-1.
31100 RA=RA*RD
31200 IF(KA.EQ.0)RA=RA-RC
31300 W=RA
31400 RB=W
31500 IF(W.LE.Z)GO TO 2020
31600 IF(Z.NE.0)GO TO 3020
31700 RA=RA/Y
31800 RB=-1.
31900 RC=0
32000 GO TO 8020
32100 3020 W=Z
32200 RC=W+RC
32300 GO TO 24
32400 2020 RC=0
32500 24 IF(X.NE.Y)GO TO 424
32600 RA=W/X
32700 GO TO 8020
32800 C DUR OF TMP + BG TIME OF TMP - NOTE VALUE -
32900 C BG TIME OF NOTE. CHN=TBG.
33000 424 RAX=XT(J)
33100 RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
33200 XT(J)=RAX+YY*RA
33300 8020 IF(KA.EQ.0)RA=RA+XA
33400 KA=1
33500 IF(RC.NE.0)GO TO 1011
33600 IF(T5.EQ.1)RETURN
33700 C T5=1 IN 'RUNIT'
33800 V(IA+K)=RA*RD
33900 IF(K.EQ.IZ)RETURN
34000 C*********** JUNE 1,71
34100 1011 IF(T5.EQ.1)GO TO 2011
34200 K=K+1
34300 IF(ZZ.NE.0)Z=Z-W
34450 IF(Z.GT.0)GO TO 7020
34475 IF(RB.EQ.-1.)GO TO 7020
34500 IC=IC+1
34600 IF(RB.EQ.W)RETURN
34700 KA=0
34800 K=K-1
34900 RETURN
35000 2011 XA=RA
35100 IF(K.GT.1)GO TO 9020
35200 K=I-6
35300 ZPAR=-9900.-CHN-ZZ
35400 DO 3011 KL=8,I
35500 IF(V(K).NE.ZPAR)GO TO 3011
35550 IF(V(K+1).EQ.990000.)GO TO 9020
35600 3011 K=K-1
35700 9020 W=ZZ
35800 IF(V(K+3))K=K+3
35900 C ABOVE IS FOR TYPED IN TEMPO CHANGES
36000 KA=K+3
36100 ZZ=V(KA)
36200 C DUR OF NEXT TEMPI
36300 X=V(KA+1)
36400 Y=V(KA+2)
36500 213 KA=0
36600 Z=ZZ
36700 CALL SQYY(YY,X,Y,Z)
36800 CHN=CHN+W
36900 XT(J)=X
37000 IF(KA.EQ.1)Z=0
37100 RA=PR
37200 KA=0
37300 K=K+3
37400 GO TO 4020
37500 END
37600
37700 SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
37800 COMMON/A/ V(2000)
37900 C TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
38000 C KODES: -22=RHY -33=NOTES -44=NUMS -46=RLIST -36=RNOTES
38100 C -11=SUBN -12=SUBR -55=MOVE NUMS -56=MOVE NOTES
38200 C -66=DUPL -88=LIT -57=MOVE RANGE NUMS -58=MOVE RNG NOTES
38300 DO 1 K=1,2000
38400 N=V(K)
38500 IF(N.LT.10000)GO TO 1
38600 IF(N/10000.NE.INUM)GO TO 1
38700 IF(MOD(N,10000).NE.IPAR)GO TO 1
38800 ISTRT=K+4
38900 KODE=V(K+2)
39000 ICNT=V(K+3)
39100 IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
39200 RETURN
39300 C FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
39400 1 CONTINUE
39500 END